home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmpcatch.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  4KB  |  108 lines
  1. ;;; CMPCATCH  Catch, Unwind-protect, and Throw.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'catch 'c1catch 'c1special)
  10. (si:putprop 'catch 'c2catch 'c2)
  11. (si:putprop 'unwind-protect 'c1unwind-protect 'c1special)
  12. (si:putprop 'unwind-protect 'c2unwind-protect 'c2)
  13. (si:putprop 'throw 'c1throw 'c1special)
  14. (si:putprop 'throw 'c2throw 'c2)
  15.  
  16. (defun c1catch (args &aux (info (make-info :sp-change t)) tag)
  17.   (when (endp args) (too-few-args 'catch 1 0))
  18.   (setq tag (c1expr (car args)))
  19.   (add-info info (cadr tag))
  20.   (setq args (c1progn (cdr args)))
  21.   (add-info info (cadr args))
  22.   (list 'catch info tag args))
  23.  
  24. (si:putprop 'push-catch-frame 'set-push-catch-frame 'set-loc)
  25.  
  26. (defun c2catch (tag body &aux (*vs* *vs*))
  27.   (let ((*value-to-go* '(push-catch-frame))) (c2expr* tag))
  28.   (wt-nl "if(nlj_active)")
  29.   (wt-nl "{nlj_active=FALSE;frs_pop();")
  30.   (unwind-exit 'fun-val 'jump)
  31.   (wt "}")
  32.   (wt-nl "else{")
  33.   (let ((*unwind-exit* (cons 'frame *unwind-exit*)))
  34.        (c2expr body))
  35.   (wt "}")
  36.   )
  37.  
  38. (defun set-push-catch-frame (loc)
  39.   (wt-nl "frs_push(FRS_CATCH," loc ");"))
  40.  
  41. (defun c1unwind-protect (args &aux (info (make-info :sp-change t)) form)
  42.   (when (endp args) (too-few-args 'unwind-protect 1 0))
  43.   (setq form (let ((*blocks* (cons 'lb *blocks*))
  44.                    (*tags* (cons 'lb *tags*))
  45.                    (*vars* (cons 'lb *vars*)))
  46.                   (c1expr (car args))))
  47.   (add-info info (cadr form))
  48.   (setq args (c1progn (cdr args)))
  49.   (add-info info (cadr args))
  50.   (list 'unwind-protect info form args)
  51.   )
  52.  
  53. (defun c2unwind-protect (form body
  54.                          &aux (*vs* *vs*) (loc (list 'vs (vs-push))))
  55.   (wt-nl "{object tag;frame_ptr fr;object p;bool active;")
  56.   (wt-nl "frs_push(FRS_PROTECT,Cnil);")
  57.   (wt-nl "if(nlj_active){tag=nlj_tag;fr=nlj_fr;active=TRUE;}")
  58.   (wt-nl "else{")
  59.   (let ((*value-to-go* 'top)) (c2expr* form))
  60.   (wt-nl "active=FALSE;}")
  61.   (wt-nl loc "=Cnil;")
  62.   (wt-nl "while(vs_base<vs_top)")
  63.   (wt-nl "{" loc "=MMcons(vs_top[-1]," loc ");vs_top--;}")
  64.   (wt-nl) (reset-top)
  65.   (wt-nl "nlj_active=FALSE;frs_pop();")
  66.   (let ((*value-to-go* 'trash)) (c2expr* body))
  67.   (wt-nl "vs_base=vs_top=base+" *vs* ";")
  68.   (base-used)
  69.   (wt-nl "for(p= " loc ";!endp(p);p=MMcdr(p))vs_push(MMcar(p));")
  70.   (wt-nl "if(active)unwind(fr,tag);else{")
  71.   (unwind-exit 'fun-val)
  72.   (wt "}}")
  73.   )
  74.  
  75. (defun c1throw (args &aux (info (make-info)) tag)
  76.   (when (or (endp args) (endp (cdr args)))
  77.         (too-few-args 'throw 2 (length args)))
  78.   (unless (endp (cddr args))
  79.           (too-many-args 'throw 2 (length args)))
  80.   (setq tag (c1expr (car args)))
  81.   (add-info info (cadr tag))
  82.   (setq args (c1expr (cadr args)))
  83.   (add-info info (cadr args))
  84.   (list 'throw info tag args)
  85.   )
  86.  
  87. (defun c2throw (tag val &aux (*vs* *vs*) loc)
  88.   (wt-nl "{frame_ptr fr;")
  89.   (case (car tag)
  90.     (LOCATION (setq loc (caddr tag)))
  91.     (VAR (let ((var (caaddr tag)))
  92.               (declare (object var))
  93.               (case (var-kind var)
  94.                     (LEXICAL (setq loc (list 'vs (var-ref var))))
  95.                     (REPLACED (setq loc (var-loc var)))
  96.                     (t (setq loc (list 'vs (vs-push)))
  97.                        (wt-nl loc "= ") (wt-var var nil) (wt ";")))))
  98.     (t (setq loc (list 'vs (vs-push)))
  99.        (let ((*value-to-go* loc)) (c2expr* tag))))
  100.  
  101.   (wt-nl "fr=frs_sch_catch(" loc ");")
  102.   (wt-nl "if(fr==NULL) FEerror(\"The tag ~s is undefined.\",1," loc ");")
  103.   (let ((*value-to-go* 'top)) (c2expr* val))
  104.   (wt-nl "unwind(fr," loc ");}")
  105.   )
  106.  
  107.  
  108.